home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / misc / files.lsp < prev    next >
Lisp/Scheme  |  1991-10-23  |  4KB  |  98 lines
  1. ;; Einige Utilities zum Umgang mit Files
  2.  
  3. ; (COPY-FILE filename newname)
  4. ; wie (RENAME-FILE filename newname),
  5. ; nur daß das alte File unverändert bleibt und der Inhalt kopiert wird.
  6. (defun copy-file (filename newname)
  7.   (let* ((oldpathname
  8.            (pathname (if (streamp filename) (truename filename) filename))
  9.          )
  10.          (newpathname (merge-pathnames newname oldpathname))
  11.         )
  12.     (with-open-file (istream oldpathname :element-type 'unsigned-byte :direction :input)
  13.       (with-open-file (ostream newpathname :element-type 'unsigned-byte :direction :output :if-exists :error)
  14.         (let* ((oldtruename (truename istream))
  15.                (newtruename (truename ostream))
  16.                (length (file-length istream))
  17.                (block-size
  18.                  (let ((room (nth-value 1 (room))))
  19.                    (when (or (> length 10000) (< room length)) (setq room (gc)))
  20.                    (min length (round (* 0.95 room)))
  21.                ) )
  22.                (block (make-string block-size))
  23.               )
  24.           (loop
  25.             (when (zerop length) (return))
  26.             (when (< length block-size) (setq block-size length))
  27.             (dotimes (i block-size)
  28.               (setf (schar block i) (int-char (read-byte istream)))
  29.             )
  30.             (dotimes (i block-size)
  31.               (write-byte (char-int (schar block i)) ostream)
  32.             )
  33.             (decf length block-size)
  34.           )
  35.           (values newpathname oldtruename newtruename)
  36. ) ) ) ) )
  37.  
  38. ; (FILE->STRING file) liefert einen String mit dem File-Inhalt.
  39. (defun file->string (file)
  40.   (with-open-file (s file :element-type 'string-char :direction :input)
  41.     (let ((eof "EOF")
  42.           (nl (string #\Newline))
  43.           (stringlist nil))
  44.       (loop
  45.         (multiple-value-bind (line terminated-by-eof) (read-line s nil eof)
  46.           (when (eq line eof) (return))
  47.           (push line stringlist)
  48.           (if (not terminated-by-eof) (push nl stringlist) (return))
  49.       ) )
  50.       #+CLISP (apply #'string-concat (nreverse stringlist))
  51.       #-CLISP (apply #'concatenate 'string  (nreverse stringlist))
  52. ) ) )
  53.  
  54. ; (STRING->FILE filename string) baut ein File mit dem String als Inhalt.
  55. (defun string->file (filename string)
  56.   (with-open-file (s filename :element-type 'string-char :direction :output)
  57.     (write-string string s)
  58.     (truename s)
  59. ) )
  60.  
  61. ; (SHOW-FILE filename) zeigt den Inhalt eines Files hexadezimal an.
  62. ; Format jeder Zeile:
  63. ; 001230  20 21 22 23 24 25 26 27 28 29 2A 2B 2C 2D 2E 2F  | !"#$%&'()*+,-./|
  64. (defun show-file (filename &optional (start-position 0))
  65.   (with-open-file (s filename :element-type 'unsigned-byte :direction :input)
  66.     (file-position s start-position)
  67.     (let ((line-length 16) (i 0) position data)
  68.       (flet ((out-line ()
  69.                (let ((data (nreverse data)))
  70.                  (format t "~%  ~6,'0X ~{ ~2,'0X~}~VT|~{~A~}~V,0T|"
  71.                            position data
  72.                            (+ (* 3 line-length) 11)
  73.                            (mapcar #'(lambda (x)
  74.                                        (let ((c (int-char x)))
  75.                                          (if (graphic-char-p c) c #\Space)
  76.                                      ) )
  77.                                    data
  78.                            )
  79.                            (+ (* 4 line-length) 12)
  80.             )) ) )
  81.         (loop
  82.           (when (zerop i) (setq position (file-position s) data nil))
  83.           (let ((next (read-byte s nil nil)))
  84.             (if next
  85.               (progn
  86.                 (push next data) (incf i)
  87.                 (when (= i line-length) (out-line) (setq i 0))
  88.               )
  89.               (progn
  90.                 (unless (zerop i) (out-line))
  91.                 (return)
  92.               )
  93.         ) ) )
  94.   ) ) )
  95.   (values)
  96. )
  97.  
  98.